home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / 041-050 / amok50 / fonttooberon / fonttooberon.mod < prev    next >
Text File  |  1993-11-04  |  10KB  |  256 lines
  1. (*---------------------------------------------------------------------------
  2. :Program.       FontToOberon.mod
  3. :Contents.      Converts Amiga fonts to oberon source code
  4. :Author.        Christian Stiens
  5. :Address.       Heustiege 2, W-4710 Lüdinghausen
  6. :Copyright.     PD
  7. :Language.      Oberon
  8. :Translator.    Amiga Oberon V1.17.1 A+L
  9. :History.       V1.0, 03-Mar-91
  10. :Usage.         FontToOberon <font-file> TO <source-file>
  11. ---------------------------------------------------------------------------*)
  12.  
  13. MODULE FontToOberon;
  14.  
  15.   (* $RangeChk- $OvflChk- $CaseChk- $ReturnChk- $NilChk- $StackChk- *)
  16.  
  17.   IMPORT
  18.     a  : Arguments,
  19.     d  : Dos,
  20.     df : DiskFont,
  21.     s  : SYSTEM,
  22.     g  : Graphics,
  23.     fs : FileSystem,
  24.     st : Strings,
  25.     e  : Exec,
  26.     c  : Conversions,
  27.     io;
  28.  
  29.   CONST (* Error messages *)
  30.     writeerr = "Write error\n";
  31.     noinput  = "Can't open input file\n";
  32.     nooutput = "Can't open output file\n";
  33.     usage    = "Usage: FontToOberon <font-file> TO <source-file>\n";
  34.     nofont   = "That's not a font\n";
  35.  
  36.   CONST
  37.     wordsPerLine = 10;
  38.  
  39.   TYPE
  40.     IntPtr = POINTER TO INTEGER;
  41.  
  42.   VAR
  43.     arg,name    : ARRAY 256 OF CHAR;
  44.     out         : fs.File;
  45.     seg         : e.BPTR;
  46.     segSize     : LONGINT;
  47.     dummy       : e.ADDRESS;
  48.     dfh         : POINTER TO df.DiskFontHeader;
  49.     numChars    : LONGINT;
  50.     numDataWords: LONGINT;
  51.     pos         : INTEGER;
  52.  
  53.   CONST
  54.     iconSize =  781;
  55.  
  56.   PROCEDURE * IconData; (* $EntryExitCode- *)
  57.   BEGIN s.INLINE(
  58.     0E310H,00001H,00000H,00000H,000CCH,0000CH,0002AH,0001BH,00006H,00001H,
  59.     00001H,000C1H,0B6A0H,000C1H,0B778H,00004H,099A6H,00000H,00000H,00000H,
  60.     00000H,00064H,00000H,00001H,0045CH,000C1H,0B5B0H,00000H,00000H,08000H,
  61.     00000H,08000H,00000H,00000H,00000H,00000H,00000H,00000H,00000H,00000H,
  62.     00000H,0002AH,0001BH,00002H,00001H,09B30H,00300H,00000H,00000H,00FFFH,
  63.     0FFFFH,0FC00H,01000H,00000H,01200H,01000H,00000H,01200H,017FFH,09FF0H,
  64.     01200H,01000H,00000H,01C00H,01673H,0C000H,01000H,01000H,00000H,01000H,
  65.     017B9H,09F80H,01000H,01000H,00000H,01000H,01667H,00000H,01000H,01000H,
  66.     00000H,01000H,017FFH,03C00H,01000H,01000H,00000H,01000H,01700H,00000H,
  67.     01000H,01000H,00000H,01000H,0139CH,0C000H,01000H,01000H,00000H,01000H,
  68.     010E7H,0C000H,01000H,01000H,00000H,01000H,01380H,00000H,01000H,01000H,
  69.     00000H,01000H,07FFFH,0FFFFH,0D000H,08000H,00000H,09000H,08000H,00000H,
  70.     09000H,08000H,00000H,09000H,07FFFH,0FFFFH,0E000H,00000H,00000H,00000H,
  71.     00000H,00000H,00000H,00FFFH,0FFFFH,0EC00H,00FFFH,0FFFFH,0EC00H,00800H,
  72.     0600FH,0EC00H,00FFFH,0FFFFH,0E000H,0098CH,03FFFH,0E000H,00FFFH,0FFFFH,
  73.     0E000H,00846H,0607FH,0E000H,00FFFH,0FFFFH,0E000H,00998H,0FFFFH,0E000H,
  74.     00FFFH,0FFFFH,0E000H,00800H,0C3FFH,0E000H,00FFFH,0FFFFH,0E000H,008FFH,
  75.     0FFFFH,0E000H,00FFFH,0FFFFH,0E000H,00C63H,03FFFH,0E000H,00FFFH,0FFFFH,
  76.     0E000H,00F18H,03FFFH,0E000H,00FFFH,0FFFFH,0E000H,00C7FH,0FFFFH,0E000H,
  77.     00FFFH,0FFFFH,0E000H,00000H,00000H,02000H,07FFFH,0FFFFH,06000H,07FFFH,
  78.     0FFFFH,06000H,07FFFH,0FFFFH,06000H,00000H,00000H,00000H,00000H,00000H,
  79.     00000H,00000H,00000H,0002AH,0001BH,00002H,00001H,09C78H,00300H,00000H,
  80.     00000H,00FFFH,0FFFFH,0FC00H,01000H,00000H,01200H,01000H,00000H,01200H,
  81.     017FFH,09FF0H,01200H,01000H,00000H,01C00H,01673H,0C000H,01000H,01000H,
  82.     00000H,01000H,017B9H,09F80H,01000H,01000H,00000H,01000H,01667H,00000H,
  83.     01000H,01000H,00080H,01000H,017FFH,03C78H,01000H,01000H,0007EH,01000H,
  84.     01700H,0007FH,01000H,01000H,0007CH,09000H,0139CH,0C074H,05000H,01000H,
  85.     00022H,03000H,010E7H,0C011H,01000H,01000H,00008H,08800H,01380H,00004H,
  86.     04400H,01000H,00002H,02200H,07FFFH,0FFFFH,01100H,08000H,00000H,08880H,
  87.     08000H,00000H,0C480H,08000H,00000H,06380H,07FFFH,0FFFFH,0FE00H,00000H,
  88.     00000H,00000H,00000H,00000H,00000H,00FFFH,0FFFFH,0EC00H,00FFFH,0FFFFH,
  89.     0EC00H,00800H,0600FH,0EC00H,00FFFH,0FFFFH,0E000H,0098CH,03FFFH,0E000H,
  90.     00FFFH,0FFFFH,0E000H,00846H,0607FH,0E000H,00FFFH,0FFFFH,0E000H,00998H,
  91.     0FFFFH,0E000H,00FFFH,0FF7FH,0E000H,00800H,0C39FH,0E000H,00FFFH,0FFFDH,
  92.     0E000H,008FFH,0FFF8H,0E000H,00FFFH,0FFE3H,06000H,00C63H,03F8BH,0A000H,
  93.     00FFFH,0FFDDH,0C000H,00F18H,03FEEH,0E000H,00FFFH,0FFF7H,07000H,00C7FH,
  94.     0FFFBH,0B800H,00FFFH,0FFFDH,0DC00H,00000H,00000H,0EE00H,07FFFH,0FFFFH,
  95.     07700H,07FFFH,0FFFFH,03B00H,07FFFH,0FFFFH,09C00H,00000H,00000H,00000H,
  96.     00000H,00000H,00000H,00000H,0000BH,04F42H,04552H,04F4EH,03A4FH,04564H,
  97.     00000H)
  98.   END IconData;
  99.  
  100.   PROCEDURE WriteString(str: ARRAY OF CHAR); (* $CopyArrays- *)
  101.   BEGIN
  102.     IF NOT fs.WriteBlock(out,s.ADR(str),st.Length(str)) THEN
  103.       io.WriteString(writeerr);
  104.       HALT(0)
  105.     END;
  106.   END WriteString;
  107.  
  108.   PROCEDURE WriteInt(i: LONGINT);
  109.     VAR str : ARRAY 40 OF CHAR;
  110.         j   : LONGINT;
  111.         n   : SHORTINT;
  112.   BEGIN
  113.     j := i; n := 1;
  114.     WHILE j >= 10 DO j := j DIV 10; INC(n) END;
  115.     IF c.IntToStr(i,str,10,n," ") THEN WriteString(str) END;
  116.   END WriteInt;
  117.  
  118.   PROCEDURE WriteHexChar(ch:CHAR);
  119.     VAR str: ARRAY 6 OF CHAR;
  120.   BEGIN
  121.     IF c.IntToHex(ORD(ch),str,3) THEN END;
  122.     str[3] := "X";
  123.     WriteString(str);
  124.   END WriteHexChar;
  125.  
  126.   PROCEDURE WriteShortSet(s:SHORTSET);
  127.     VAR i:INTEGER;
  128.         flag:BOOLEAN;
  129.   BEGIN
  130.     WriteString("SHORTSET{");
  131.     i:=0; flag := FALSE;
  132.     WHILE i < 8 DO
  133.       IF i IN s THEN
  134.         IF flag THEN WriteString(",") END;
  135.         WriteInt(i); flag := TRUE;
  136.       END; INC(i)
  137.     END;
  138.     WriteString("}");
  139.   END WriteShortSet;
  140.  
  141.   PROCEDURE WriteHexBlock(name: ARRAY OF CHAR; block: IntPtr; numWords: LONGINT); (* $CopyArrays- *)
  142.     VAR hexStr: ARRAY 8 OF CHAR;
  143.         n:INTEGER;
  144.   BEGIN
  145.     WriteString("PROCEDURE * "); WriteString(name); WriteString("; (* $EntryExitCode- *)\n");
  146.     WriteString("BEGIN sys.INLINE(");
  147.     n := 0;
  148.     WHILE numWords > 0 DO
  149.       IF n = 0 THEN WriteString("\n  "); END;
  150.       INC(n); IF n=wordsPerLine THEN n:=0 END;
  151.       IF c.IntToHex(block^,hexStr,5) THEN END;
  152.       hexStr[0] := "0";
  153.       WriteString(hexStr);
  154.       IF numWords#1 THEN WriteString(",") END;
  155.       INC(block,2); DEC(numWords);
  156.     END;
  157.     WriteString(")\nEND "); WriteString(name); WriteString(";\n\n");
  158.   END WriteHexBlock;
  159.  
  160.   PROCEDURE Letter(ch:CHAR):BOOLEAN;
  161.   BEGIN
  162.     RETURN (CAP(ch) >="A") & (CAP(ch) <= "Z") OR (ch >="0") & (ch <= "9")
  163.   END Letter;
  164.  
  165.   PROCEDURE ExtractName(VAR str: ARRAY OF CHAR);  (* dev:name.ext -> Name *)
  166.     VAR i,j,k:INTEGER;
  167.   BEGIN
  168.     i:=st.Length(str);
  169.     LOOP
  170.       DEC(i); IF (i<0) OR (str[i]=":") OR (str[i]="/") THEN EXIT END;
  171.     END; j:=i;
  172.     LOOP
  173.       INC(j);
  174.       IF (j >= st.Length(str)) OR ~Letter(str[j]) THEN EXIT END
  175.     END; k:=0;
  176.     LOOP
  177.       INC(i); IF i=j THEN EXIT END;
  178.       str[k] := str[i]; INC(k);
  179.     END;
  180.     IF k < LEN(str) THEN str[k]:=0X END;
  181.     str[0] := CAP(str[0]);
  182.   END ExtractName;
  183.  
  184. BEGIN
  185.   seg := NIL;
  186.   a.GetArg(2,arg); st.Upper(arg);
  187.   IF (a.NumArgs()#3) OR (arg#"TO") THEN io.WriteString(usage); HALT(0) END;
  188.   a.GetArg(1,arg);
  189.   seg := d.LoadSeg(arg);
  190.   IF seg # NIL THEN
  191.     DEC(seg);
  192.     segSize := seg^;
  193. (*  io.WriteString("segSize: ");io.WriteInt(segSize,1);io.WriteLn;*)
  194.     INC(seg);
  195.     dummy := seg; dfh := dummy;
  196.     INC(dfh,8);
  197.     IF dfh.fileId # df.dfhId THEN io.WriteString(nofont);HALT(0) END;
  198.     a.GetArg(3,arg); COPY(arg,name); ExtractName(name);
  199.     IF ~fs.Open(out,arg,TRUE) THEN io.WriteString(nooutput); HALT(0) END;
  200.     io.WriteString("Creating file "); io.WriteString(arg); io.WriteLn;
  201.     numChars := ORD(dfh.tf.hiChar) - ORD(dfh.tf.loChar) + 2;
  202. (*  io.WriteString("numChars: ");io.WriteInt(numChars,1);io.WriteLn;*)
  203.     WriteString("MODULE "); WriteString(name); WriteString(";\n\n");
  204.     WriteString("IMPORT\n  e:Exec, g:Graphics, sys:SYSTEM;\n\n");
  205.     WriteString("VAR\n  font * : g.TextFontPtr;\n\n");
  206.     numDataWords := (segSize-12-s.SIZE(df.DiskFontHeader)) DIV 2-numChars*2;
  207.     IF dfh.tf.charSpace # NIL THEN DEC(numDataWords,numChars) END;
  208.     IF dfh.tf.charKern  # NIL THEN DEC(numDataWords,numChars) END;
  209. (*  io.WriteString("numDataWords: "); io.WriteInt(numDataWords,1); io.WriteLn;*)
  210. (*  io.WriteString("charData: ");io.WriteInt(dfh.tf.charData,1);io.WriteLn;*)
  211. (*  io.WriteString("charLoc: ");io.WriteInt(dfh.tf.charLoc,1);io.WriteLn;*)
  212. (*  io.WriteString("charSpace: ");io.WriteInt(dfh.tf.charSpace,1);io.WriteLn;*)
  213. (*  io.WriteString("charKern: ");io.WriteInt(dfh.tf.charKern,1);io.WriteLn;*)
  214.     WriteHexBlock("CharData",dfh.tf.charData,numDataWords);
  215.     WriteHexBlock("CharLoc",dfh.tf.charLoc,2*numChars);
  216.     IF dfh.tf.charSpace # NIL THEN
  217.       WriteHexBlock("CharSpace",dfh.tf.charSpace,numChars);
  218.     END;
  219.     IF dfh.tf.charKern # NIL THEN
  220.       WriteHexBlock("CharKern",dfh.tf.charKern,numChars);
  221.     END;
  222.     WriteString("BEGIN\n");
  223.     WriteString("  NEW(font)");
  224.     WriteString(";\n  font.message.node.type := e.font");
  225.     WriteString(";\n  font.message.node.name := sys.ADR(\""); WriteString(dfh.name);WriteString("\")");
  226.     WriteString(";\n  font.message.length    := sys.SIZE(g.TextFont)");
  227.     WriteString(";\n  font.ySize     := "); WriteInt(dfh.tf.ySize);
  228.     WriteString(";\n  font.style     := "); WriteShortSet(dfh.tf.style);
  229.     WriteString(";\n  font.flags     := "); WriteShortSet(dfh.tf.flags);
  230.     WriteString(";\n  font.xSize     := "); WriteInt(dfh.tf.xSize);
  231.     WriteString(";\n  font.baseline  := "); WriteInt(dfh.tf.baseline);
  232.     WriteString(";\n  font.boldSmear := "); WriteInt(dfh.tf.boldSmear);
  233.     WriteString(";\n  font.accessors := 0");
  234.     WriteString(";\n  font.loChar    := "); WriteHexChar(dfh.tf.loChar);
  235.     WriteString(";\n  font.hiChar    := "); WriteHexChar(dfh.tf.hiChar);
  236.     WriteString(";\n  font.charData  := CharData");
  237.     WriteString(";\n  font.modulo    := "); WriteInt(dfh.tf.modulo);
  238.     WriteString(";\n  font.charLoc   := "); WriteString("CharLoc");
  239.     WriteString(";\n  font.charSpace := "); IF dfh.tf.charSpace # NIL THEN WriteString("CharSpace") ELSE WriteString("NIL") END;
  240.     WriteString(";\n  font.charKern  := "); IF dfh.tf.charKern  # NIL THEN WriteString("CharKern")  ELSE WriteString("NIL") END;
  241.     WriteString("\nEND "); WriteString(name); WriteString(".\n");
  242.     IF fs.Close(out) THEN END;
  243.     st.Append(arg,".info");
  244.     IF fs.Open(out,arg,TRUE) THEN
  245.       IF fs.WriteBlock(out,IconData,iconSize) THEN END;
  246.       IF fs.Close(out) THEN END;
  247.     END;
  248.     io.WriteString("--- Done\n");
  249.   ELSE
  250.     io.WriteString(noinput);
  251.   END;
  252. CLOSE
  253.   IF seg # NIL THEN d.UnLoadSeg(seg) END;
  254. END FontToOberon.
  255.  
  256.